perm filename LAPX[S,DWP] blob
sn#080419 filedate 1974-01-10 generic text, type T, neo UTF8
00100 (SETQ IBASE (SETQ BASE (ADD1 7)))
00200 (HGHCOR 17100)
00300 (DEFPROP SPECIAL (NIL . T) VALUE)
00400 (DEFPROP LAPLST (NIL . NIL) VALUE)
00500 (DEFPROP REMOB (NIL) VALUE)
00600
00700 (DEFPROP LAP
00800 (LAMBDA(SL)
00900 (PROG (L MARKLST COM0 REMOB LL)
01000 (SETQ COM0 (GENSYM))
01100 (SETQ MARKLST (LIST NIL))
01200 (SETQ L BPORG)
01300 A (COND ((NULL (SETQ LL (READ))) (GO END))
01400 ((ATOM LL) (DEFSYM LL L) (GO A)))
01500 (DEPOSIT L (MAKNUM (GWD LL) (QUOTE FIXNUM)))
01600 (FREELIST LL)
01700 (SETQ L (ADD1 L))
01800 (GO A)
01900 END (DEFSYM COM0 L)
02000 EN1 (COND
02100 ((NULL (SETQ MARKLST (CDR MARKLST)))
02200 (APPLY# (QUOTE REMOB) REMOB)
02300 (FREELIST REMOB)
02400 (PUTPROP (CAR SL) (NUMVAL BPORG) (CADR SL))
02500 (RETURN (SETQ SL (LIST (CAR SL) L)))))
02600 (SETQ KLIST (CONS (CONS (CAR MARKLST) L) KLIST))
02700 (DEPOSIT L (MAKNUM (GWD (CAR MARKLST)) (QUOTE FIXNUM)))
02800 (SETQ L (ADD1 L))
02900 (GO EN1))
03000 (AND (REMPROP (CAR SL) (QUOTE NOCALL)) (DEFSYM (CAR SL) BPORG))
03100 (SETQ BPORG (CADR SL))
03200 SL)
03300 FEXPR)
03400
03500
03600 (DEFPROP TYPE
03700 (LAMBDA (X) (COND ((NUMBERP X) (CADR X))))
03800 EXPR)
03900
04000
04100 (DEFPROP GWD
04200 (LAMBDA(X)
04300 (NUMVAL (PROG (WRD FLD)
04400 (SETQ FLD
04500 (QUOTE
04600 ((22 . -1) (27 . 17) (0 . 777777) (22 . 777777))))
04700 (SETQ WRD 0)
04800 (MAPC (FUNCTION
04900 (LAMBDA(ZZ)
05000 (PROG2 (SETQ WRD
05100 (*PLUS WRD
05200 (LSH (BOOLE 1
05300 (CDAR FLD)
05400 (LAPEVAL ZZ))
05500 (CAAR FLD))))
05600 (SETQ FLD (CDR FLD)))))
05700 X)
05800 (COND ((EQ (CADDDR X) (QUOTE S))
05900 (SETQ WRD (*DIF WRD (EXAMINE 11)))))
06000 (RETURN WRD))))
06100 EXPR)
06200
06300
06400 (DEFPROP LAPEVAL
06500 (LAMBDA(X)
06600 (COND ((NUMBERP X) X)
06700 ((ATOM X) (GVAL X))
06800 ((MEMQ (CAR X) (QUOTE (E QUOTE)))
06900 (MAKNUM
07000 (COND
07100 ((OR (CONSP (SETQ X (CADR X))) (AND (NUMBERP X) (NEQ (*PLUS X 0) X)) (STRINGP X))
07200 (PROG (Y)
07300 (SETQ Y QLIST)
07400 A (COND ((NULL Y) (RETURN (CAR (SETQ QLIST (CONS X QLIST)))))
07500 ((AND (EQUAL X (CAR Y)) (EQ (TYPE X) (TYPE (CAR Y)))) (RETURN (CAR Y))))
07600 (SETQ Y (CDR Y))
07700 (GO A)))
07800 (T X))
07900 (QUOTE FIXNUM)))
08000 ((EQ (CAR X) (QUOTE SPECIAL))
08100 (COND ((NULL (GET (CADR X) (QUOTE VALUE))) (PUTPROP (CADR X) (CONS NIL (UNBOUND)) (QUOTE VALUE))))
08200 (PROG (Y)
08300 (RPLACA (SETQ Y (GET (CADR X) (QUOTE VALUE))) NIL)
08400 (AND SPECIAL (NOT (ASSOC Y LAPLST)) (SETQ LAPLST (CONS (CONS Y (CADR X)) LAPLST)))
08500 (RETURN (MAKNUM Y (QUOTE FIXNUM)))))
08600 ((EQ (CAR X) (QUOTE C))
08700 (PROG (N CPTR)
08800 (SETQ CPTR KLIST)
08900 L11 (COND ((NULL CPTR) (GO L12)) ((EQUAL (CDR X) (CAAR CPTR)) (RETURN (CDAR CPTR))))
09000 (SETQ CPTR (CDR CPTR))
09100 (GO L11)
09200 L12 (GVAL COM0)
09300 (SETQ N 0)
09400 (SETQ CPTR MARKLST)
09500 A (COND ((NULL (CDR CPTR)) (RPLACD CPTR (LIST (CDR X))) (RETURN N)))
09600 (COND ((EQUAL (CDR X) (CADR CPTR)) (RETURN N)))
09700 (SETQ N (ADD1 N))
09800 (SETQ CPTR (CDR CPTR))
09900 (GO A)))
10000 (T (*PLUS (LAPEVAL (CAR X)) (LAPEVAL (CDR X))))))
10100 EXPR)
10200
10300
10400 (DEFPROP DEFSYM
10500 (LAMBDA(SYM VAL)
10600 (PROG (Z)
10700 (SETQ REMOB (CONS SYM REMOB))
10800 (COND ((SETQ Z (GET SYM (QUOTE UNDEF))) (GO PATCH)))
10900 A (RETURN (PUTPROP SYM VAL (QUOTE SYM)))
11000 PATCH
11100 (COND ((NULL Z) (REMPROP SYM (QUOTE UNDEF)) (GO A)))
11200 (DEPOSIT (CAR Z) (*PLUS (EXAMINE (CAR Z)) VAL))
11300 (SETQ Z (CDR Z))
11400 (GO PATCH)))
11500 EXPR)
11600
11700
11800 (DEFPROP GVAL
11900 (LAMBDA(SYM)
12000 (COND ((GET SYM (QUOTE SYM)))
12100 ((GET SYM (QUOTE VALUE)) (MAKNUM SYM (QUOTE FIXNUM)))
12200 (T (PUTPROP SYM
12300 (CONS L (GET SYM (QUOTE UNDEF)))
12400 (QUOTE UNDEF))
12500 0)))
12600 EXPR)
12700
12800
12900 (DEFPROP OPS
13000 (LAMBDA(L)
13100 (PROG NIL
13200 A (COND ((NULL L) (RETURN T)))
13300 (PUTPROP (CAR L) (CADR L) (QUOTE SYM))
13400 (SETQ L (CDDR L))
13500 (GO A)))
13600 FEXPR)
13700
13800 (OPS MOVE 200000 MOVEI 201000 MOVEM 202000 JRST 254000 CALL 34000 JCA→
13900 LL 35000 PUSHJ 260000 POPJ 263000 PUSH 261000 POP 262000 P 14 JSP 265→
14000 000 EXCH 250000 JUMPE 322000 JUMPN 326000 SOJE 362000 SOJN 366000 CAI→
14100 E 302000 CAIN 306000 CAME 312000 CAMN 316000 CALLF 36000 JCALLF 37000→
14200 HRRZ@ 550020 HLRZ@ 554020 TDZA 634000 SUB 274000 HRRZ 550000 HLRZ 55→
14300 4000 CLEARM 402000 CLEARB 403000 ADD 270000 MOVNI 211000 CALLF@ 36020→
14400 JCALLF@ 37020 HRRM@ 542020 HRLM@ 506020 HRRZS@ 553020 HLLZS@ 513020 →
14500 HRRM 542000 S 11 D 12)
14600 (COND ((NULL (GET (QUOTE QLIST) (QUOTE VALUE))) (SETQ QLIST NIL)))
14700 (COND ((NULL (GET (QUOTE KLIST) (QUOTE VALUE))) (SETQ KLIST NIL)))
14800
14900 (SETQ BORG1 BPORG)
15000 (SETQ BEND1 BPEND)
15100 (SETQ BPORG (HGHORG NIL))
15200 (SETQ BPEND (HGHEND))
15300
15400 (DEFPROP REMLAP
15500 (LAMBDA NIL
15600 (PROG (Z)
15700 (SETQ Z (QUOTE (LAP LAPEVAL GWD DEFSYM REMLAP OPS GVAL TYPE)))
15800 A (COND ((NULL Z) (GO B)))
15900 (REMPROP (CAR Z) (QUOTE EXPR))
16000 (REMPROP (CAR Z) (QUOTE FEXPR))
16100 (SETQ Z (CDR Z))
16200 (GO A)
16300 B (REMPROP (QUOTE REMLAP) (QUOTE EXPR))
16400 (REMOB REMLAP WRD FLD SL LL Z VAL END EN1 L11 L12 PATCH)))
16500 EXPR)
16600
16700 (LAP GWD SUBR)
16800 (PUSH P (C 0))
16900 (PUSH P 1)
17000 (PUSHJ P G0123)
17100 (506000 1 -1 P)
17200 (PUSHJ P G0123)
17300 (242000 1 27)
17400 (436000 1 -1 P)
17500 (PUSHJ P G0123)
17600 (HRRM 1 -1 P)
17700 (PUSHJ P G0123)
17800 (CAIE 1 S)
17900 (JRST 0 G0122)
18000 (210000 2 S)
18100 (272000 2 -1 P)
18200 G0122 (514000 1 1)
18300 (436000 1 -1 P)
18400 G0124 (POP P 1)
18500 (POP P 1)
18600 (POPJ P)
18700 G0125 (POP P 1)
18800 (JRST 0 G0124)
18900 G0123 (MOVE 2 -1 P)
19000 (JUMPE 2 G0125)
19100 (HLRZ 1 0 2)
19200 (HRRZ 2 0 2)
19300 (MOVEM 2 -1 P)
19400 (CALL 1 (E LAPEVAL) S)
19500 (JRST 0 NUMVAL)
19600 NIL